home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / let_nodes.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  9.7 KB  |  258 lines
  1. (herald let_nodes)
  2.  
  3. ;;;   This is a backquote-like macro for building node trees.  The format is
  4. ;;; meant to look like the output of PP-CPS.  There is as yet no way to
  5. ;;; construct OBJECT nodes.
  6. ;;;
  7. ;;;   The goal is to produce code that is as efficient as possible.
  8. ;;;
  9. ;;; (LET-NODES (<spec1> ... <specN>) . <body>)
  10. ;;;
  11. ;;; <spec> ::= (<ident> <real-call>) |                            ; call node
  12. ;;;            (<ident> (<var1> ... <varN>) <call>) |             ; lambda node
  13. ;;;            (<ident> (<var1> ... <varN> . <last-vars>) <call>) ; lambda node
  14. ;;;
  15. ;;; <call> ::= <ident> | <real-call>
  16. ;;;
  17. ;;; <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
  18. ;;;                 (<arg0> <exits> <arg1> ... <argN> . <last-args>))
  19. ;;;
  20. ;;; <var>  ::= () |               ; Ignored variable position
  21. ;;;            <ident> |          ; Create a variable with this name
  22. ;;;            (<ident> <value>)  ; Evaluate <value> to get the variable
  23. ;;;
  24. ;;; <last-args> ::= <ident>
  25. ;;;
  26. ;;; <last-vars> ::= <ident>
  27. ;;;
  28. ;;; <arg>  ::= ($ foo)      primop node for foo (which evaluates to a primop)
  29. ;;;            'foo         literal node containing the value of foo
  30. ;;;            (* foo)      reference to foo (which evaluates to a variable)
  31. ;;;            (! foo)      foo evaluates to a node
  32. ;;;            name         short for (! name) when foo is an atom
  33. ;;;            (^ name)     same as name (used for lambda nodes)
  34. ;;;
  35. ;;; Example:
  36. ;;;
  37. ;;; (let-nodes ((c1 ((^ l1) 1 cont))
  38. ;;;              (l1 (() v1)
  39. ;;;                  (($ primop/conditional) 2 (^ l2) (^ l3) primop arg1 arg2))
  40. ;;;                (l2 (()) ((* v1) 0 ''#t))
  41. ;;;                (l3 (()) ((* v1) 0 ''#f)))
  42. ;;;   (replace node c1))
  43. ;;;
  44. ;;;  ==>
  45. ;;;
  46. ;;; (LET ((V1 (CREATE-VARIABLE 'V1)))
  47. ;;;   (LET ((C1 (CREATE-CALL-NODE 2 1))
  48. ;;;         (C_1 (CREATE-CALL-NODE 6 2))
  49. ;;;         (L1 (CREATE-LAMBDA-NODE 'C (FLIST2 '() V1 '())))
  50. ;;;         (C_2 (CREATE-CALL-NODE 2 0))
  51. ;;;         (L2 (CREATE-LAMBDA-NODE 'C (FLIST1 '() '())))
  52. ;;;         (C_3 (CREATE-CALL-NODE 2 0))
  53. ;;;         (L3 (CREATE-LAMBDA-NODE 'C (FLIST1 '() '()))))
  54. ;;;     (RELATE CALL-PROC C1 L1)
  55. ;;;     (RELATE (CALL-ARG 1) C1 CONT)
  56. ;;;     (RELATE CALL-PROC C_1 (CREATE-PRIMOP-NODE PRIMOP/CONDITIONAL))
  57. ;;;     (RELATE-FIVE-CALL-ARGS C_1 L2 L3 PRIMOP ARG1 ARG2)
  58. ;;;     (RELATE LAMBDA-BODY L1 C_1)
  59. ;;;     (RELATE CALL-PROC C_2 (CREATE-REFERENCE-NODE V1))
  60. ;;;     (RELATE (CALL-ARG 1) C_2 (CREATE-LITERAL-NODE '#t))
  61. ;;;     (RELATE LAMBDA-BODY L2 C_2)
  62. ;;;     (RELATE CALL-PROC C_3 (CREATE-REFERENCE-NODE V1))
  63. ;;;     (RELATE (CALL-ARG 1) C_3 (CREATE-LITERAL-NODE '()))
  64. ;;;     (RELATE LAMBDA-BODY L3 C_3)
  65. ;;;     (REPLACE NODE C1)))
  66. ;;;
  67.  
  68. (define-syntax (let-nodes specs . body)
  69.   (receive (vars nodes code)
  70.            (parse-node-specs specs)
  71.     `(let ,vars
  72.        (let ,nodes
  73.          ,@code
  74.          ,@body))))
  75.  
  76. ;;; Parse the specs, returning a list of variable specs, a list of node specs,
  77. ;;; and a list of construction forms.  An input spec is either a call or a
  78. ;;; lambda, each is parsed by an appropriate procedure.
  79.  
  80. (define (parse-node-specs specs)
  81.   (iterate loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '()))
  82.     (if (null? specs)
  83.         (return vars nodes codes)
  84.         (destructure ((((name . spec) . rest) specs))
  85.           (cond ((null? (cdr spec))
  86.                  (receive (node code)
  87.                           (construct-call name (car spec))
  88.                    (loop rest vars
  89.                          `((,name ,node) . ,nodes) (append code codes))))
  90.                 ((fx= 2 (length spec))
  91.                  (receive (vs node new-spec call)
  92.                           (construct-lambda (car spec) (cadr spec))
  93.                    (loop (if new-spec (cons new-spec rest) rest)
  94.                          (append vs vars)
  95.                          `((,name ,node) . ,nodes)
  96.                          (if call 
  97.                              `((relate lambda-body ,name ,call) . ,codes)
  98.                              codes))))
  99.                 (else
  100.                  (error "illegal spec in LET-NODES ~S" (cons name spec))))))))
  101.  
  102. ;;; The names of the call-arg relation procedures, indexed by the number of
  103. ;;; arguments handled.
  104.  
  105. (define call-relate-names
  106.   '#(#f
  107.      #f
  108.      relate-two-call-args
  109.      relate-three-call-args
  110.      relate-four-call-args
  111.      relate-five-call-args))
  112.  
  113. ;;; Return the node spec and construction forms for a call.  This dispatches
  114. ;;; on whether the argument list is proper or not.
  115. ;;;
  116. ;;; <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
  117. ;;;                 (<arg0> <exits> <arg1> ... <argN> . <last-args>))
  118.  
  119. (define (construct-call name specs)
  120.   (destructure (((proc exits . args) specs))
  121.     (receive (list last)
  122.              (decouple-improper-list args)
  123.       (cond ((null? last)
  124.              (construct-proper-call name proc exits args))
  125.             (else
  126.              (construct-improper-call name proc exits list last))))))
  127.  
  128. ;;; Return proper part of the list and its last-cdr seperately.
  129.  
  130. (define (decouple-improper-list list)
  131.   (do ((list list (cdr list))
  132.        (res '() (cons (car list) res)))
  133.       ((atom? list)
  134.        (return (reverse! res) list))))
  135.  
  136. ;;; Returns
  137. ;;;   (CREATE-CALL-NODE <length of args + 1> <exits>)
  138. ;;; and
  139. ;;;   ((RELATE-CALL-PROC <name> <procedure code>)
  140. ;;;    . <argument relation code>)
  141. ;;; The form of <argument relation code> depends on the number of arguments.
  142.  
  143. (define (construct-proper-call name proc exits args)
  144.   (let* ((args (map construct-node args)) 
  145.          (arg-code (cond ((null? args) '())
  146.                          ((null? (cdr args))
  147.                           `((relate (call-arg 1) ,name ,(car args))))
  148.                          ((fx< (length args) 6)
  149.                           `((,(vref call-relate-names (length args))
  150.                              ,name ,@args)))
  151.                          (else
  152.                           `((relate-call-args ,name (list ,args)))))))
  153.       (return `(create-call-node ,(fx+ 1 (length args)) ,exits)
  154.               `((relate call-proc ,name ,(construct-node proc))
  155.                 . ,arg-code))))
  156.  
  157. ;;; Returns
  158. ;;;   (CREATE-CALL-NODE (fx+ (LENGTH <last-arg>) <length of args + 1>) <exits>)
  159. ;;; and
  160. ;;;   ((RELATE-CALL-PROC <name> <procedure code>)
  161. ;;;    (RELATE-CALL-ARGS <name> (APPEND <args> <last-arg>)))
  162.  
  163. (define (construct-improper-call name proc exits args last-arg)
  164.   (let* ((args (map construct-node args))
  165.          (arg-code (if (null? args)
  166.                        last-arg
  167.                        `(append! (list . ,args) ,last-arg))))
  168.       (return `(create-call-node (fx+ ,(fx+ 1 (length args))
  169.                                       (length ,last-arg))
  170.                                  ,exits)
  171.               `((relate call-proc ,name ,(construct-node proc))
  172.                 (relate-call-args ,name ,arg-code)))))
  173.  
  174. ;;; Dispatch on the type of the SPEC and return the appropriate code.
  175. ;;;
  176. ;;; <arg>  ::= ($ foo)      primop node for foo (which evaluates to a primop)
  177. ;;;            'foo         literal node containing the value of foo
  178. ;;;            (* foo)      reference to foo (which evaluates to a variable)
  179. ;;;            (! foo)      foo evaluates to a node
  180. ;;;            name         short for (! name) when foo is an atom
  181. ;;;            (^ name)     same as name (used for lambda nodes)
  182.  
  183. (define (construct-node spec)
  184.   (cond ((atom? spec) spec)
  185.         (else
  186.          (case (car spec)
  187.            (($) `(create-primop-node ,(cadr spec)))
  188.            ((^) (cadr spec))
  189.            ((*) `(create-reference-node ,(cadr spec)))
  190.            ((quote) `(create-literal-node ,(cadr spec)))
  191.            ((!) (cadr spec))
  192.            (else
  193.             (error "CONSTRUCT-NODE confused by ~S in LET-NODE" spec))))))
  194.  
  195. ;;; Parse a lambda spec.  This returns a list of variable specs, code to
  196. ;;; construct the lambda node, a spec for the body if necessary, and
  197. ;;; the code needed to put it all together.
  198.  
  199. (define (construct-lambda vars call)
  200.   (receive (vars node)
  201.            (construct-vars vars)
  202.     (cond ((null? call)
  203.            (return vars node nil nil))
  204.           ((atom? call)
  205.            (return vars node nil call))
  206.           (else
  207.            (let ((sym (generate-symbol 'c)))
  208.              (return vars node `(,sym ,call) sym))))))
  209.  
  210. ;;; Returns the code needed to construct the variables and the code to make
  211. ;;; the lambda node that binds the variables.
  212. ;;;
  213. ;;; <var>  ::= () |               ; Ignored variable position
  214. ;;;            <ident> |          ; Create a variable with this name
  215. ;;;            (<ident> <value>)  ; Evaluate <value> to get the variable
  216.  
  217. (define (construct-vars vars)
  218.   (iterate loop ((vs vars) (vlist '()) (code '()))
  219.     (cond ((null? vs)
  220.            (return code
  221.                    `(create-lambda-node 'c ,(flistify (reverse! vlist) ''()))))
  222.           ((atom? vs)
  223.            (return code
  224.                    `(create-lambda-node 'c ,(flistify (reverse! vlist) vs))))
  225.           ((null? (car vs))         
  226.            (loop (cdr vs) (cons ''() vlist) code))
  227.           ((list? (car vs))
  228.            (loop (cdr vs) (cons (caar vs) vlist)
  229.                  `((,(caar vs) ,(cadar vs)) . ,code)))
  230.           (else
  231.            (loop (cdr vs) (cons (car vs) vlist)
  232.                  `((,(car vs) (create-variable ',(car vs))) . ,code))))))
  233.  
  234. ;;; The names of the free-list constructing procedures, indexed by the
  235. ;;; number of arguments they take.
  236.  
  237. (define flist-names '#(#f flist1 flist2 flist3 flist4 flist5))
  238.  
  239. ;;; Returns code to construct a free-list of the SPECS, with the last-cdr
  240. ;;; of LAST.
  241.  
  242. (define (flistify specs last)
  243.   (cond ((null? specs)
  244.          last) 
  245.         ((fx< (length specs) 6)
  246.          `(,(vref flist-names (length specs)) ,@specs ,last))
  247.         (else
  248.          (let ((rest (cddddr specs)))
  249.            `(flist5 ,(car specs)
  250.                     ,(cadr specs)
  251.                     ,(caddr specs)
  252.                     ,(cadddr specs)
  253.                     ,(car rest)
  254.                     ,(flistify (cdr rest) last))))))
  255.  
  256.  
  257.  
  258.